home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-doc.lzh / cdecl / const.sc < prev    next >
Text File  |  1991-10-11  |  4KB  |  113 lines
  1. ;;; C declaration compiler.
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. ;;; This module compiles constant expressions.
  42. ;;;
  43. ;;;    (const <identifier> <expression>)
  44. ;;;
  45. ;;; which defines a constant.  The expression is evaluated at compile time
  46. ;;; and is defined as the following:
  47. ;;;
  48. ;;;    <expression> ::= <constant-symbol>
  49. ;;;                 Scheme-constant
  50. ;;;                 ( Scheme-procedure [ <expression> ... ] )
  51. ;;;
  52. ;;; When stubs are being generated, this will result in:
  53. ;;;
  54. ;;;    (define <identifier> <value>)
  55. ;;;
  56. ;;; and when an include file is being generated, it will generate:
  57. ;;;
  58. ;;;    (define-constant <identifier> <value>)
  59.  
  60. (module const)
  61.  
  62. ;;; During the input phase, the following function is called to process
  63. ;;; constant expressions.  It will return either the constant or call error
  64. ;;; on an error.
  65.  
  66. (define (INPUT-CONST exp)
  67.     (if (and (= (length exp) 3) (symbol? (cadr exp)))
  68.     (let ((id (cadr exp)))
  69.          (putprop id 'const (cddr exp))
  70.          id)
  71.     (error 'input-const "Illegal syntax: ~s" exp)))
  72.  
  73. ;;; A constant value is computed by the following expression.  Any errors will
  74. ;;; be reported by calling error.
  75.  
  76. (define (CONST-VALUE const)
  77.     (cond ((symbol? const)
  78.        (let ((value (getprop const 'const)))
  79.         (if value
  80.             (const-value (car value))
  81.             (error 'const-value "Undefined constant: ~s"
  82.                const))))
  83.       ((pair? const)
  84.        (let ((proc (top-level-value (car const))))
  85.         (if (procedure? proc)
  86.             (apply proc (map const-value (cdr const)))
  87.             (error 'const-value "Undefined function: ~s"
  88.                (car const)))))
  89.       (else const)))
  90.  
  91. ;;; Stub declarations are generated by the following function.
  92.  
  93. (define (EMIT-CONSTS constants define-only const-file-root)
  94.     (with-output-to-file
  95.     (string-append const-file-root ".sc")
  96.     (lambda ()
  97.         (format #t "(module ~a)~%~%" const-file-root)
  98.         (for-each
  99.             (lambda (const)
  100.                 (unless (memq const define-only)
  101.                     (format #t "(define ~s ~s)~%"
  102.                         const (const-value const))))
  103.             constants)))
  104.     (with-output-to-file
  105.     (string-append const-file-root ".sch")
  106.     (lambda ()
  107.         (for-each
  108.             (lambda (const)
  109.                 (unless (memq const define-only)
  110.                     (format #t "(define-constant ~s ~s)~%"
  111.                         const (const-value const))))
  112.             constants))))
  113.